Attribute VB_Name = "mCRC24"

' +--------------------------------------------------------------------------+
' |                                                                          |
' |  Modul:          CRC24                                                   |
' |  Version:        1.00 - 16.09.2009                                       |
' |  Lizenz:         Keine. Frei verwendbar!                                 |
' |  Sprache:        Visual Basic 6.0                                        |
' |  Entwickler:     Vincenz Dreger                                          |
' |  Homepage:       http://vd-software.inside1.net                          |
' |                                                                          |
' |  Beschreibung:   CRC24 eines Strings/Byte-Arrays berechnen.              |
' |                                                                          |
' +--------------------------------------------------------------------------+
' |                                                                          |
' |  Funktionen:     CRC24     = CRC24 von String berechnen.                 |
' |                  CRC24B    = CRC24 von Byte-Array berechnen.             |
' |                  HexCRC24  = CRC24 von String als HEX-String ausgeben.   |
' |                  HexCRC24B = CRC24 von Byte-Array als HEX-String ...     |
' |                                                                          |
' +--------------------------------------------------------------------------+
' |                                                                          |
' |  Verweis:        RFC 4480 .. http://tools.ietf.org/html/rfc4880#page-54  |
' |                                                                          |
' |  Haftung:                                                                |
' |                                                                          |
' |    1. Die Verwendung geschieht auf eigene Gefahr!                        |
' |                                                                          |
' |    2. Der Author übernimmt keine Haftung bei eventuellen                 |
' |       Schäden, welche durch die Verwendung entstehen könnten!            |
' |                                                                          |
' +--------------------------------------------------------------------------+

Option Explicit

Const CRC24_INIT As Long = &HB704CE
Const CRC24_POLY As Long = &H1864CFB

Public Const ExistCRC24 As Boolean = True


'CRC24 von String berechnen und als Hex-String ausgeben
Public Function HexCRC24(ByVal InString As String) As String
  HexCRC24 = Right$("000000" + Hex$(CRC24(InString)), 6)
End Function


'CRC24 von Byte-Array berechnen und als Hex-String ausgeben
Public Function HexCRC24B(InBytes() As Byte) As String
  HexCRC24B = Right$("000000" + Hex$(CRC24B(InBytes())), 6)
End Function


'CRC24 von String berechnen und als Long ausgeben
Public Function CRC24(ByVal InString As String) As Long
  Dim InBytes() As Byte
  InBytes = StrConv(InString, vbFromUnicode)
  CRC24 = CRC24B(InBytes)
End Function


'CRC24 von Byte-Array berechnen und als Long ausgeben
Public Function CRC24B(InBytes() As Byte) As Long
  Dim BytPos As Long
  Dim BitPos As Integer
  Dim CRC As Long
  CRC = CRC24_INIT
  For BytPos = LBound(InBytes) To UBound(InBytes)
    CRC = CRC Xor LeftShift16(InBytes(BytPos))
    For BitPos = 0 To 7
      CRC = LeftShift1(CRC)
      If (CRC And &H1000000) <> 0 Then
        CRC = CRC Xor CRC24_POLY
      End If
    Next
  Next
  CRC24B = CRC And &HFFFFFF
End Function


'32-Bit Long um 16 Bits nach links schieben. Entspreicht dem Ausdruck
'"WordX << 16" in C. Verhindert Problem mit Vorzeichen-Bit.
Private Function LeftShift16(ByVal WordX As Long) As Long
  LeftShift16 = (WordX And &H7FFF&) * &H10000
  If (WordX And &H8000&) <> 0 Then
    LeftShift16 = LeftShift16 Or &H80000000
  End If
End Function


'32-Bit Long um 1 Bit nach links schieben. Entspreicht dem Ausdruck
'"WordX << 1" in C. Verhindert Problem mit Vorzeichen-Bit.
Private Function LeftShift1(ByVal WordX As Long) As Long
  LeftShift1 = (WordX And &H7FFFFFFF) * &H2
  If (WordX And &H8000000) <> 0 Then
    LeftShift1 = LeftShift1 Or &H80000000
  End If
End Function